COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(LET ((FASLOAD ())) (FASLOAD UMATCH))
C00033 ENDMK
C⊗;
(LET ((FASLOAD ())) (FASLOAD UMATCH))
(load "umatch.126")
(car %/#p)
(car %/#d)
(step %umatch)
(trace %%umatch)

(%umatch '((all ?x (some ?y) (foo ?x ?y)))
	 '((all ?x (some ?y) (foo ?y ?x))))

(%umatch '((all ?x (some ?y) (foo ?x ?y)))
	 '((all ?x (some ?y) (foo ?X ?Y))))

(%umatch '(A ?X ?y) '(A ?y ?x))
(%umatch '(?X ?y) '(?y ?x))
(%umatch '(A *X B) '(A ?X ?Y B))

(%UMATCH '(A ?X B) '(A (?X) B))
(%UMATCH '(A ?X B) '(A ?X B))
(%umatch '(?q ?x) '(can-fly tweety))

(%umatch '((all ?x bird)(can-fly ?x))
	 '((ALL ?Y ?CLASS) (?Q ?Y)) )

(%umatch '((?a ?b ?c) ?d) '((all ?x ?foo) 4))

(let (fasload)(fasload umatch))
(%umatch-pair '((?a1 ?b1 ?c1) ?d1) '((?x1 ?y1 ?z1) ?w1))
(%umatch      '((?a1 ?b1 ?c1) ?d1) '((?x1 ?y1 ?z1) ?w1))
(%umatch '(($ch ?x) ?y)'(1 2))
(%umatch-PAIR '(= ($ch 1) 2)'(= ($ch ?x) ?y))
(%umatch-PAIR '(a  1 2)'(a ($ch ?x) ?y))
(%umatch-PAIR '(($CH 1) 2)'(($CH ?x) 2))

UMATCH-ALIST
(TRACE %%UMATCH)
(UNTRACE)
(MAKUNBOUND '?B)
(STEP CLAUSE-*-VARIABLE)
(%umatch '(?B B) '(*A B))
?B
*A
(%%special-formp '(-special-form- . *))

(progn (break t t) (print 'foo))

;;; Macros for Unification
(DECLARE (SETSYNTAX 35. 2 35.))
(DECLARE (SPECIAL %/#CONTINUE %/#CONTINUE-STACK %/#RETAIN %/#CE %/#ALIST COMPILE-MACROS UMATCH-ALIST))
(declare (special %/#full-predicate %/#OCCURS))
(setq %/#full-predicate ())
(declare (fasload struct fas dsk (mac lsp)))

;;; %/#CONTINUE is T if this is a rematch. %/#RETAIN says
;;; whether or not to save information for a rematch
;;; %/#CONTINUE-STACK saves * information for the rematch
(SETQ %/#CONTINUE NIL %/#CONTINUE-STACK NIL %/#RETAIN NIL COMPILE-MACROS NIL %/#OCCURS () UMATCH-ALIST ())

(DEFUN %%OCCURS (X L)
       (COND ((MEMQ L (CDR (ASSQ X %/#OCCURS))) T)
	     ((EQ X L) ())
	     (T (%%OCCURS1 X L L))))

(DEFUN %%OCCURS1 (X L TOP)
       (COND ((NULL L) ())
	     ((EQ X L) (LET ((ENTRY (ASSQ X %/#OCCURS)))
			    (COND (ENTRY
				   (NCONC ENTRY `(,TOP)))
				  (T (PUSH `(,X . (,TOP))
					   %/#OCCURS))))
		       T)
	     ((ATOM L) ())
	     (T (OR (%%OCCURS1 X (CAR L) TOP)
		    (%%OCCURS1 X (CDR L) TOP)))))

(MACRODEF MAKE-SPECIAL-FORM (X) (CONS '-SPECIAL-FORM- X))

(MACRODEF SPECIAL-FORM (X)
 (LET QQQ ← X DO
	  (COND ((%%SPECIAL-FORMP QQQ)
		 '-SPECIAL-FORM-)
		(T QQQ))) )

(MACRODEF %%CHAR1 (ATOM) 
       ;; returns the 1st character of an atom.
       (COND ((EQ (TYPEP ATOM) 'SYMBOL) (GETCHAR ATOM 1.))))

(MACRODEF REAL-ATOM (%/#X)(AND %/#X (ATOM %/#X))) 



(DECLARE (SPECIAL -SEEN-))

(DEFUN %%CHECK (L)
  ((LAMBDA(-SEEN-)
    (%%CHECK1 L)) ())) 

(DEFUN %%CHECK1 (L)
 (COND ((MEMQ L -SEEN-) L)
       ((ATOM L) L)
       ((HUNKP L) (PUSH L -SEEN-) L)
       ((EQ (CAR L) '-SPECIAL-FORM-)
	(CDR L))
       ((MEMQ (CAR L) '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR $CH $CHOOSE))
	(CADR L))
       (T 
	(PUSH l -SEEN-)
	(CONS (%%CHECK1 (CAR L) )
	      (%%CHECK1 (CDR L))))))  

(MACRODEF PROCESSED-SPECIAL-FORMP (X)
	  (LET ((Q X))
	       (COND ((ATOM Q) ())
		     (T (EQ (CAR Q) '-SPECIAL-FORM-)))))

(MACRODEF ALL-TRUE (FUN %/#L)
 (APPLY 'AND 
	(MAPCAR 
	 (FUNCTION  
	  (LAMBDA (%Q%)
		   (COND ((OR (RESTRICTP %Q%)
			      (%%SPECIAL-FORMP %Q%)
			      (FUNCALL FUN %Q%)) 
			      T))))
		     %/#L)))

(MACRODEF RESTRICTP (%/#X) (AND (NOT (ATOM %/#X))
			     (MEMQ (CAR %/#X) '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR))))


(MACRODEF EXCHANGE (X Y)
  ((LAMBDA (Q)
	   (SETQ X Y)
	   (SETQ Y Q))
   X))


(DEFUN %%SPECIAL-FORMP (X)
       (COND (%/#FULL-PREDICATE ())
	     ((ATOM X)
	      (OR (EQ X '-SPECIAL-FORM-)
		  (AND (NOT (EQ X '=))
		       (MEMQ (%%CHAR1 X) '(? * =)))))
	     (T (OR (EQ (CAR X) '-SPECIAL-FORM-)
		    (RESTRICTP X))))  )

(MACRODEF CLAUSE-?-RESTRICTIONS (P D CP CD ALIST)
	  (COND
	   ((EQ (CADAR P) '?)
	    ;;; normal case of ($r ? ...)
	    (COND ((%%SPECIAL-FORMP (CAR D))
		   (SETQ P (CONS (CONS '-SPECIAL-FORM- (CAR P)) (CDR P)))
		   (EXCHANGE P D)(EXCHANGE CP CD))
		  (T 
		   (SETQ P (CDR P) D (CDR D))))
	    (GO UMATCH)) 
	   ((EQ (%%CHAR1 (CADAR P)) '?)
	    ;;; case of ($r ?foo ...)
	    ((LAMBDA (%T%) 
	      (COND (%T% (SETQ P (CONS (SPECIAL-FORM (CDR %T%)) (CDR P)))
			 (GO UMATCH))
		     (T 
		      (LET ((SPECP ())(RESTRP ()))
		      (COND (
		      (*CATCH '%/#DECISION-POINT
		       (COND 
			((%%OCCURS (CADAR P) (COND ((RESTRICTP (CAR D))
						    (CADAR D))
						   (T (CAR D))))
			 ())
			((%%SPECIAL-FORMP (CAR D))
			 (LET ((G (GENSYM))
			       (ALIST ALIST))
			      (COND ((RESTRICTP (CAR D))
				     (COND ((EQ (%%CHAR1 (CADAR D))
						'?)
					    (SETQ SPECP T RESTRP T)
					    (PUSH (CONS (CADAR D) G) ALIST))))
				    ((EQ (%%CHAR1 (CAR D)) '?)
				     (SETQ SPECP T)
				     (PUSH (CONS (CAR D) G) ALIST)))
			  (COND ((PROCESSED-SPECIAL-FORMP (CAR D))
				 (%%UMATCH (CDR D) (CDR P) CD CP
				    (CONS (CONS (CAR P)
						G) ALIST) NOBIND))
				(T (%%UMATCH D P CD CP 
					     (CONS (CONS (CAR P)
							 G) ALIST) NOBIND)))))
			(T (%%UMATCH (CDR P)(CDR D) CP CD
				     (CONS (CONS (CADAR P)
						 (CAR D))
					   ALIST) NOBIND)))  
		       )
		      (CASEQ NOBIND
			     (PAIR (PUSH `(,(CADAR P) . ,(%%CHECK (CAR D)))
					 UMATCH-ALIST)
				   (COND (SPECP
					  (COND (RESTRP
						 (PUSH `(,(CADAR D) . ,(%%CHECK (CADAR P)))
						       UMATCH-ALIST))
						(T (PUSH `(,(CAR D) . ,(%%CHECK (CADAR P)))
							 UMATCH-ALIST))))))
			     (() (SET (CADAR P) (%%CHECK (CAR D)))
				 (COND (SPECP
					(COND (RESTRP
					       (SET (CADAR D) (%%CHECK (CADAR P))))
					      (T (SET (CAR D) (%%CHECK (CADAR P))))))))
			     (T ()))
		      (*THROW '%/#DECISION-POINT T ))
			    (T (*THROW '%/#DECISION-POINT ())))))))
	      (ASSQ (CADAR P) ALIST)))))

(MACRODEF CLAUSE-*-RESTRICTIONS (P D CP CD ALIST)
	  (COND ((EQ (CADAR P) '*)
		 ((LAMBDA (L)
			  (COND (%/#CONTINUE
				 ;(OR %/#CONTINUE-STACK (*THROW '%/#DECISION-POINT NIL ))
				 ;;; initialize for continuation
				 (SETQ L (PROG2 NIL (CAR %/#CONTINUE-STACK)
						(SETQ %/#CONTINUE-STACK 
						      (CDR %/#CONTINUE-STACK))))
				 (SETQ D (DO ((L L (CDR L))
					      (D D (CDR D)))
					     ((NULL L) D)))
				 (COND ((NULL D)
					(SETQ P (CDR P))
					(GO UMATCH))))
				(T (SETQ L NIL)))
			  ;;; try all possibilities
			  (DO ((L L (NCONC L (NCONS (CAR D))))
			       (SP (%%SPECIAL-FORMP (CAR D)))
			       (OD D OD)
			       (OP P OP)
			       (D D (CDR D))
			       (E (CONS NIL D) (CDR E)))
			      ((NULL E) (*THROW '%/#DECISION-POINT NIL ))
			      (COND ((APPLY 'AND
					    (MAPCAR 
					     (FUNCTION
					      (LAMBDA (Q)
						      (COND
						       ((FUNCALL Q L)
							T))))
					     (CDDAR P))) 
				     (COND 
				      ((*CATCH '%/#DECISION-POINT
					       (COND
						((AND L
						      (%%SPECIAL-FORMP (CAR OD)))
						 (%%UMATCH
						  OD OP CD CP ALIST NOBIND))
						(T 
						 (%%UMATCH (CDR P) D CP CD
							   ALIST NOBIND))) 
					       )
				       (AND SP
					    (*CATCH '%/#DECISION-POINT
					       (%%UMATCH L
							 (NCONS (MAKE-SPECIAL-FORM (CAR P)))
							 CP CD
							 (CONS (CONS (CAR P) L) ALIST) NOBIND)))
				       (AND %/#RETAIN 
					    (SETQ %/#CONTINUE-STACK
						  (CONS L %/#CONTINUE-STACK)))
				       (*THROW '%/#DECISION-POINT T )))))))
		  NIL))
		((EQ (%%CHAR1 (CADAR  P)) '*)
		 ((LAMBDA (%T%) 
			   (COND (%T% (COND((APPLY 'AND
						   (MAPCAR
						    (FUNCTION
						     (LAMBDA (Q)
							     (COND 
							      ((FUNCALL Q (CDR %T%))
									T))))
						     (CDDAR P)))
						   (SETQ P (APPEND 
							    (SPECIAL-FORM (CDR %T%)) (CDR P)))
							 (GO UMATCH)) 
						   (T (*THROW '%/#DECISION-POINT NIL ))))
				       (T ((LAMBDA(L)
					    (COND (%/#CONTINUE
						   (SETQ L (SYMEVAL (CAR P)))
						   (SETQ D (DO ((L L (CDR L))
								(D D (CDR D)))
							       ((NULL L) D)))
						   (COND ((NULL D)
							  (SETQ P (CDR P))
							  (GO UMATCH))))
						  (T (SETQ L NIL)))
					    (DO ((L L (NCONC L (NCONS (CAR D))))
						 (SP (%%SPECIAL-FORMP (CAR D)))
						 (OP P OP)
						 (OD D OD)
						 (D D (CDR D))
						 (E (CONS NIL D) (CDR E)))
						((NULL E) (*THROW '%/#DECISION-POINT NIL ))
						(COND
						 ((APPLY
						   'AND
						   (MAPCAR
						    (FUNCTION
						     (LAMBDA (Q)
							     (COND((FUNCALL Q L)
								   T))))
						    (CDDAR P)))
						  (COND 
						   ((*CATCH '%/#DECISION-POINT
							    (COND 
							     ((AND L
								   (%%SPECIAL-FORMP (CAR OD)))
							      (%%UMATCH OD OP CD CP
									(CONS
									 (CONS (CADAR P) 
									       (CONS 
										(CONS 
										 '-SPECIAL-FORM- 
										 (CAR OD))
										(CDR L)))
									 ALIST) NOBIND))  
							     (T (%%UMATCH 
								 (CDR P) D CP CD
								 (CONS
								  (CONS (CADAR P) 
									L)
								  ALIST) NOBIND))  )
							    )
						    (AND SP
							 (*CATCH '%/#DECISION-POINT
							    (%%UMATCH L
								      (NCONS (MAKE-SPECIAL-FORM (CAR P)))
								      CP CD
								      (CONS (CONS (CAR P) L) ALIST) NOBIND)))
						    (CASEQ NOBIND
							   (PAIR (PUSH `(,(CADAR P) . ,(%%CHECK L))
								UMATCH-ALIST))
							   (() (SET (CADAR P) (%%CHECK L)))
							   (T ()))
						    (*THROW '%/#DECISION-POINT T )))))))   
					   NIL))))
				 (ASSQ (CADAR P) ALIST)))))  
(MACRODEF CLAUSE-*-IRESTRICTIONS (P D CP CD ALIST)
	  (COND ((EQ (CADAR P) '*)
		 ((LAMBDA (L)
			  (COND (%/#CONTINUE
				 ;(OR %/#CONTINUE-STACK (*THROW '%/#DECISION-POINT NIL ))
				 ;;; initialize for continuation
				 (SETQ L (PROG2 NIL (CAR %/#CONTINUE-STACK)
						(SETQ %/#CONTINUE-STACK 
						      (CDR %/#CONTINUE-STACK))))
				 (SETQ D (DO ((L L (CDR L))
					      (D D (CDR D)))
					     ((NULL L) D)))
				 (COND ((NULL D)
					(SETQ P (CDR P))
					(GO UMATCH))))
				(T (SETQ L NIL)))
			  ;;; try all possibilities
			  (DO ((L L (NCONC L (NCONS (CAR D))))
			       (F (CAR D)(CAR D))
			       (SP (%%SPECIAL-FORMP (CAR D)))
			       (D D (CDR D))
			       (E (CONS NIL D) (CDR E)))
			      ((NULL E) (*THROW '%/#DECISION-POINT NIL ))
			      (COND ((APPLY 'AND
					    (MAPCAR 
					     (FUNCTION
					      (LAMBDA (Q)
						      (COND
						       ((OR (NULL L)
							    (RESTRICTP F)
							    (%%SPECIAL-FORMP F)
							    (FUNCALL Q F))
							T))))
					     (CDDAR P))) 
				     (COND 
				      ((*CATCH '%/#DECISION-POINT
					       (COND ((AND L
							   (%%SPECIAL-FORMP (CAR D)))
						      (%%UMATCH D (CDR P) CD CP ALIST NOBIND))
						     (T (%%UMATCH (CDR P) D CP CD
								  ALIST NOBIND)))
					       )
				       (AND SP
					    (*CATCH '%/#DECISION-POINT
					       (%%UMATCH L
							 (NCONS (MAKE-SPECIAL-FORM (CAR P)))
							 CP CD
							 (CONS (CONS (CAR P) L) ALIST) NOBIND)))
				       (AND %/#RETAIN (SETQ %/#CONTINUE-STACK
							    (CONS L %/#CONTINUE-STACK)))
				       (*THROW '%/#DECISION-POINT T )))))))
		  NIL))
		((EQ (%%CHAR1 (CADAR  P)) '*)
		 ((LAMBDA (%T%) 
			   (COND 
			    (%T% 
			     (COND
			      ((APPLY 
				'AND
				(MAPCAR
				 (FUNCTION
				  (LAMBDA (Q)
					  (COND ((OR (RESTRICTP %T%)
								(ALL-TRUE Q %T%))
								T))))
					  (CDDAR P)))
				 (COND ((*CATCH '%/#DECISION-POINT
						(%%UMATCH
						 (CAR P)(CAR D) () () ALIST NOBIND)
						)
					(SETQ P (APPEND (SPECIAL-FORM (CDR %T%)) (CDR P)))
					      (GO UMATCH)) 
					(T (*THROW '%/#DECISION-POINT () 
						   ))))  
				 (T (*THROW '%/#DECISION-POINT NIL ))))
			       (T ((LAMBDA(L)
				    (COND (%/#CONTINUE
					   (SETQ L (SYMEVAL (CAR P)))
					   (SETQ D (DO ((L L (CDR L))
							(D D (CDR D)))
						       ((NULL L) D)))
					   (COND ((NULL D)
						  (SETQ P (CDR P))
						  (GO UMATCH))))
					  (T (SETQ L NIL)))
				    (DO ((L L (NCONC L (NCONS (CAR D))))
					 (F (CAR D)(CAR D))
					 (OD D OD)
					 (SP (%%SPECIAL-FORMP (CAR D)))
					 (OP P OP)
					 (D D (CDR D))
					 (E (CONS NIL D) (CDR E)))
					((NULL E) (*THROW '%/#DECISION-POINT NIL ))
					(COND
					 ((APPLY
					   'AND
					   (MAPCAR
					    (FUNCTION
					     (LAMBDA (Q)
						     (COND ((OR (NULL L)
								(RESTRICTP F)
								(%%SPECIAL-FORMP F)
								(FUNCALL Q F))
							    T))))
					    (CDDAR P)))
					  (COND 
					   ((*CATCH '%/#DECISION-POINT
						    (COND ((AND L
								(%%SPECIAL-FORMP (CAR OD)))
							   (%%UMATCH OD OP CD CP
								     (CONS
								      (CONS (CADAR P)
									    (CONS (CONS 
										   '-SPECIAL-FORM- 
										   (CAR OD)) (CDR L)))
								      ALIST) NOBIND))  
							  (T 
							   (%%UMATCH (CDR P) D CP CD
								     (CONS
								      (CONS (CADAR P) L)
								      ALIST) NOBIND)))
						    )
					    (AND SP
					    (*CATCH '%/#DECISION-POINT
						    (%%UMATCH L
							      (NCONS (MAKE-SPECIAL-FORM (CAR P)))
							      CP CD
							      (CONS (CONS (CAR P) L) ALIST) NOBIND)))
					    (CASEQ NOBIND
						   (PAIR (PUSH `(,(CADAR P) . ,(%%CHECK L))
							       UMATCH-ALIST))
						   (() (SET (CADAR P) (%%CHECK L)))
						   (T ()))
					    (*THROW '%/#DECISION-POINT T )))))))
				   NIL))))
			     (ASSQ (CADAR P) ALIST)) ))) 
		  
(MACRODEF CLAUSE-?-VARIABLE (P D CP CD ALIST)
 ((LAMBDA (%T%) 
   (COND (%T% (SETQ P (CONS (SPECIAL-FORM (CDR %T%)) (CDR P)))
		    (GO UMATCH))
	  (T 
	   (LET ((SPECP ())
		 (RESTRP ()))
	   (COND 
	    ((*CATCH '%/#DECISION-POINT
	      (COND ((%%OCCURS (CAR P) (COND ((RESTRICTP (CAR D))
						(CADAR D))
					       (T (CAR D))))
		     ())
		    ((%%SPECIAL-FORMP (CAR D))
		     (LET ((G (GENSYM))
			   (ALIST ALIST))
			  (COND ((RESTRICTP (CAR D))
				 (COND ((EQ (%%CHAR1 (CADAR D))
					    '?)
					(SETQ SPECP T RESTRP T)
					(PUSH (CONS (CADAR D) G) ALIST))))
				((EQ (%%CHAR1 (CAR D)) '?)
				 (SETQ SPECP T)
				 (PUSH (CONS (CAR D) G) ALIST)))
			  (COND ((PROCESSED-SPECIAL-FORMP (CAR D))
				 (%%UMATCH (CDR D) (CDR P) CD CP
				    (CONS (CONS (CAR P)
						G) ALIST) NOBIND))
				(T (%%UMATCH D P CD CP 
					     (CONS (CONS (CAR P)
							 G) ALIST) NOBIND)))))
		    (T 
		     (%%UMATCH (CDR P)(CDR D) CP CD
			       (CONS (CONS (CAR P)(CAR D))ALIST) NOBIND))) 
	      )
	     (CASEQ NOBIND
		    (PAIR (PUSH `(,(CAR P) . ,(%%CHECK (CAR D)))
				UMATCH-ALIST)
			  (COND (SPECP
				 (COND (RESTRP
					(PUSH `(,(CADAR D) . ,(%%CHECK (CAR P)))
					      UMATCH-ALIST))
				       (T (PUSH `(,(CAR D) . ,(%%CHECK (CAR P)))
					       UMATCH-ALIST))))))
		    (() (SET (CAR P) (%%CHECK (CAR D)))
			(COND (SPECP
			       (COND (RESTRP
				      (SET (CADAR D) (%%CHECK (CAR P))))
				     (T (SET (CAR D) (%%CHECK (CAR P))))))))
		    (T ()))
	     (*THROW '%/#DECISION-POINT T ))  
	    (T (*THROW '%/#DECISION-POINT () )))))))   
   (ASSQ (CAR P) ALIST)))
  
(MACRODEF CLAUSE-* (P D CP CD ALIST)
 ((LAMBDA (L)
	  (COND (%/#CONTINUE
		 ;(OR %/#CONTINUE-STACK (*THROW '%/#DECISION-POINT NIL ))
		 ;;; initialize for continuation
		 (SETQ L (PROG2 NIL (CAR %/#CONTINUE-STACK)
				(SETQ %/#CONTINUE-STACK 
				      (CDR %/#CONTINUE-STACK))))
		 (SETQ D (DO ((L L (CDR L))
			      (D D (CDR D)))
			     ((NULL L) D)))
		 (COND ((NULL D)
			(SETQ P (CDR P))
			(GO UMATCH))))
		(T (SETQ L NIL)))
	  ;;; try all possibilities
	  (DO ((L L (NCONC L (NCONS (CAR D))))
	       (D D (CDR D))
	       (SP (%%SPECIAL-FORMP (CAR D)))
	       (E (CONS NIL D) (CDR E)))
	      ((NULL E) (*THROW '%/#DECISION-POINT NIL ))
	      (COND 
	       ((*CATCH '%/#DECISION-POINT
			(COND
			 ((AND L
			       (%%SPECIAL-FORMP (CAR D)))
			  (%%UMATCH D (CDR P) CP CD ALIST NOBIND))
			 (T (%%UMATCH (CDR P) D CP CD ALIST NOBIND) ))
			)
		(AND SP
		     (*CATCH '%/#DECISION-POINT
			(%%UMATCH L
				  (NCONS (MAKE-SPECIAL-FORM (CAR P)))
				  CP CD
				  (CONS (CONS (CAR P) L) ALIST) NOBIND)))
		(AND %/#RETAIN (SETQ %/#CONTINUE-STACK
				     (CONS L %/#CONTINUE-STACK)))
		(*THROW '%/#DECISION-POINT T )))))
  NIL))

(MACRODEF CLAUSE-*-VARIABLE (P D CP CD ALIST)
  ((LAMBDA (%T%) 
   (COND (%T% (SETQ P (APPEND (SPECIAL-FORM (CDR %T%)) (CDR P)))
		    (GO UMATCH))
	  (T ((LAMBDA(L)
	       (COND (%/#CONTINUE
		      (SETQ L (SYMEVAL (CAR P)))
		      (SETQ D (DO ((L L (CDR L))
				   (D D (CDR D)))
				  ((NULL L) D)))
		      (COND ((NULL D)
			     (SETQ P (CDR P))
			     (GO UMATCH))))
		     (T (SETQ L NIL)))
	       (DO ((L L (NCONC L (NCONS (CAR D))))
		    (D D (CDR D))
		    (SP (%%SPECIAL-FORMP (CAR D)))
		    (E (CONS NIL D) (CDR E)))
		   ((NULL E) (*THROW '%/#DECISION-POINT NIL ))
		   (COND 
		    ((*CATCH '%/#DECISION-POINT
			     (%%UMATCH (CDR P) D CP CD
				       (CONS (CONS (CAR P) L)
					     ALIST) NOBIND)
		      )
		     (AND SP
			  (*CATCH '%/#DECISION-POINT
				  (%%UMATCH L
					    (NCONS (MAKE-SPECIAL-FORM (CAR P)))
					    CP CD
					    (CONS (CONS (CAR P) L) ALIST) NOBIND)))
		     (CASEQ NOBIND
			    (PAIR (PUSH `(,(CAR P) . ,(%%CHECK L))
					UMATCH-ALIST))
			    (() (SET (CAR P) (%%CHECK L)))
			    (T ()))
		     (*THROW '%/#DECISION-POINT T )))))
	      NIL))))
   (ASSQ (CAR P) ALIST)) )     
  
(MACRODEF CLAUSE-=?-VARIABLE (P D CP CD ALIST)
  ((LAMBDA (%T%) 
	   (COND ((EQ (CAR %T%) '?)
		  ((LAMBDA (VAR)
			   ((LAMBDA (VAL)
				    (COND (VAL (SETQ P (CONS (CDR VAL) (CDR P))))
					  (T
					   (SETQ P 
						 (CONS (SYMEVAL VAR) (CDR P))))) 
				    (GO UMATCH))
			    (ASSQ VAR %/#ALIST)))
		   (IMPLODE %T%)))
		  (T 
		   ((LAMBDA (VAR)
			    ((LAMBDA (VAL)
				     (COND (VAL (SETQ P (APPEND (CDR VAL) (CDR P))))
					   (T
					    (SETQ P 
						  (APPEND (SYMEVAL VAR) (CDR P))))) 
				     (GO UMATCH))
			     (ASSQ VAR %/#ALIST)))
		    (IMPLODE %T%)))))
		  (CDR (EXPLODE (CAR P)))))